home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / More Examples / Hennessy3.MOD < prev    next >
Encoding:
Text File  |  1992-10-09  |  10.4 KB  |  537 lines  |  [TEXT/MEDT]
  1. MODULE Hennessy3;
  2.  
  3. FROM Storage IMPORT ALLOCATE;
  4. FROM SYSTEM IMPORT VAL, TSIZE;
  5. FROM SYSTEM IMPORT REG, SETREG;
  6. FROM InOut IMPORT WriteLn, WriteString, WriteInt, Read, OpenOutput, CloseOutput;
  7.  
  8.  
  9. CONST
  10.     bubblebase = 1.61;
  11.     quickbase = 1.92;
  12.     treebase =  2.5;
  13.     puzzlebase = 0.5;
  14.  
  15.     (* Puzzle *)
  16.     size = 511;
  17.     classmax = 3;
  18.     typemax = 12;
  19.     d = 8D;
  20.  
  21.     (* Bubble, Quick *)
  22.     sortelements = 5000;
  23.     srtelements = 500;
  24.  
  25.  
  26. TYPE
  27.     (* tree *)
  28.     node = POINTER TO nodeDesc;
  29.     nodeDesc = RECORD
  30.         left, right: node;
  31.         val: LONGINT;
  32.     END;
  33.  
  34.  
  35.     Proc = PROCEDURE;
  36.  
  37. VAR
  38.     fixed,floated: REAL; ch: CHAR;
  39.  
  40.     (* global *)
  41.     seed: LONGINT;
  42.  
  43.     (* tree *)
  44.     tree: node;
  45.  
  46.     (* Puzzle *)
  47.     piececount: ARRAY [0..classmax] OF LONGINT;
  48.     class, piecemax: ARRAY [0..typemax] OF LONGINT;
  49.     puzzl: ARRAY [0..size] OF BOOLEAN;
  50.     p: ARRAY [0..typemax], [0..size] OF BOOLEAN;
  51.     n,
  52.     kount: LONGINT;
  53.  
  54.     (* Bubble, Quick *)
  55.     sortlist: ARRAY [0..sortelements] OF LONGINT;
  56.     biggest, littlest,
  57.     top: LONGINT;
  58.  
  59.  
  60. (* global procedures *)
  61.  
  62. PROCEDURE Getclock (): LONGINT;
  63.     TYPE P = POINTER TO LONGINT;
  64.     VAR ticks: P; tk: LONGINT;
  65. BEGIN    ticks := VAL(P, 16AH);
  66.     tk := ticks^; RETURN TRUNCD(FLOATD(tk) * (1000.0D0/60.0D0) + 0.5D0)
  67. END Getclock;
  68.  
  69. PROCEDURE Initrand ();
  70. BEGIN seed := 74755D
  71. END Initrand;
  72.  
  73. PROCEDURE Rand (): LONGINT;
  74. BEGIN
  75.     seed := (seed * 1309D + 13849D) MOD 65535D;
  76.     RETURN (seed);
  77. END Rand;
  78.  
  79.     (* A compute-bound program from Forest Baskett. *)
  80.  
  81.     PROCEDURE Fit (i, j: LONGINT): BOOLEAN;
  82.         VAR k: LONGINT;
  83.     BEGIN k := 0;
  84.         WHILE k <= piecemax[i] DO
  85.             IF ( p[i][k] ) THEN IF ( puzzl[j+k] ) THEN RETURN FALSE END END;
  86.             INC(k)
  87.         END;
  88.         RETURN TRUE
  89.     END Fit;
  90.  
  91.     PROCEDURE Place (i, j: LONGINT): LONGINT;
  92.         VAR k: LONGINT;
  93.     BEGIN k := 0;
  94.         WHILE k <= piecemax[i] DO
  95.             IF ( p[i][k] ) THEN puzzl[j+k] := TRUE END;
  96.             INC(k)
  97.         END;
  98.         piececount[class[i]] := piececount[class[i]] - 1D;
  99.         k := j;
  100.         WHILE k <= LONG(size) DO
  101.             IF ( ~ puzzl[k] ) THEN RETURN (k) END;
  102.             INC(k)
  103.         END ;
  104.         RETURN (0);
  105.     END Place;
  106.  
  107.     PROCEDURE Remove (i, j: LONGINT);
  108.         VAR k: LONGINT;
  109.     BEGIN k := 0;
  110.         WHILE k <= piecemax[i] DO
  111.             IF ( p[i][k] ) THEN puzzl[j+k] := FALSE END;
  112.             INC(k)
  113.         END;
  114.         piececount[class[i]] := piececount[class[i]] + 1D
  115.     END Remove;
  116.  
  117.     PROCEDURE Trial (j: LONGINT): BOOLEAN;
  118.         VAR i, k: LONGINT;
  119.     BEGIN i := 0;
  120.         kount := kount + 1D;
  121.         WHILE i <= LONG(typemax) DO
  122.             IF ( piececount[class[i]] # 0D) THEN
  123.                 IF ( Fit (i, j) ) THEN
  124.                     k := Place (i, j);
  125.                     IF Trial(k) OR (k = 0D) THEN RETURN (TRUE)
  126.                     ELSE Remove (i, j)
  127.                     END;
  128.                 END
  129.             END;
  130.             INC(i)
  131.         END;
  132.         RETURN (FALSE)
  133.     END Trial;
  134.  
  135. PROCEDURE Puzzle ();
  136.     VAR i, j, k, m: LONGINT;
  137. BEGIN
  138.     m := 0D; WHILE m <= LONG(size) DO puzzl[m] := TRUE; INC(m) END ;
  139.     i := 1;
  140.     WHILE i <= 5D DO j := 1D;
  141.         WHILE j <= 5D DO k := 1D;
  142.             WHILE k <= 5D DO
  143.                 puzzl[i+d*(j+d*k)] := FALSE; INC(k)
  144.             END;
  145.             INC(j)
  146.         END;
  147.         INC(i)
  148.     END;
  149.  
  150.     i := 0D;
  151.     WHILE i <= LONG(typemax) DO m := 0;
  152.         WHILE m<= LONG(size) DO
  153.             p[i][m] := FALSE; INC(m)
  154.         END;
  155.         INC(i)
  156.     END;
  157.  
  158.     i := 0D;
  159.     WHILE i <= 3D DO j := 0D;
  160.         WHILE j <= 1D DO k := 0D;
  161.             WHILE k <= 0D DO
  162.                 p[0][i+d*(j+d*k)] := TRUE; INC(k)
  163.             END;
  164.             INC(j)
  165.         END;
  166.         INC(i)
  167.     END;
  168.     class[0] := 0D;
  169.     piecemax[0] := 3D+d*1D+d*d*0D;
  170.  
  171.     i := 0D;
  172.     WHILE i <= 1D DO j := 0D;
  173.         WHILE j <= 0D DO k := 0D;
  174.             WHILE k <= 3D DO
  175.                 p[1][i+d*(j+d*k)] := TRUE; INC(k)
  176.             END;
  177.             INC(j)
  178.         END;
  179.         INC(i)
  180.     END;
  181.     class[1] := 0D;
  182.     piecemax[1] := 1D+d*0D+d*d*3D;
  183.  
  184.     i := 0D;
  185.     WHILE i <= 0D DO j := 0D;
  186.         WHILE j <= 3D DO k := 0D;
  187.             WHILE k <= 1D DO
  188.                 p[2][i+d*(j+d*k)] := TRUE; INC(k)
  189.             END;
  190.             INC(j)
  191.         END;
  192.         INC(i)
  193.     END;
  194.     class[2] := 0D;
  195.     piecemax[2] := 0D+d*3D+d*d*1D;
  196.  
  197.     i := 0D;
  198.     WHILE i <= 1D DO j := 0D;
  199.         WHILE j <= 3D DO k := 0D;
  200.             WHILE k <= 0D DO
  201.                 p[3][i+d*(j+d*k)] := TRUE; INC(k)
  202.             END;
  203.             INC(j)
  204.         END;
  205.         INC(i)
  206.     END;
  207.     class[3] := 0D;
  208.     piecemax[3] := 1D+d*3D+d*d*0D;
  209.  
  210.     i := 0D;
  211.     WHILE i <= 3D DO j := 0D;
  212.         WHILE j <= 0D DO k := 0D;
  213.             WHILE k <= 1D DO
  214.                 p[4][i+d*(j+d*k)] := TRUE; INC(k)
  215.             END;
  216.             INC(j)
  217.         END;
  218.         INC(i)
  219.     END;
  220.     class[4] := 0D;
  221.     piecemax[4] := 3D+d*0D+d*d*1D;
  222.  
  223.     i := 0D;
  224.     WHILE i <= 0D DO j := 0D;
  225.         WHILE j <= 1D DO k := 0D;
  226.             WHILE k <= 3D DO
  227.                 p[5][i+d*(j+d*k)] := TRUE; INC(k)
  228.             END;
  229.             INC(j)
  230.         END;
  231.         INC(i)
  232.     END;
  233.     class[5] := 0D;
  234.     piecemax[5] := 0D+d*1D+d*d*3D;
  235.  
  236.     i := 0D;
  237.     WHILE i <= 2D DO j := 0D;
  238.         WHILE j <= 0D DO k := 0D;
  239.             WHILE k <= 0D DO
  240.                 p[6][i+d*(j+d*k)] := TRUE; INC(k)
  241.             END;
  242.             INC(j)
  243.         END;
  244.         INC(i)
  245.     END;
  246.     class[6] := 1D;
  247.     piecemax[6] := 2D+d*0D+d*d*0D;
  248.  
  249.     i := 0D;
  250.     WHILE i <= 0D DO j := 0D;
  251.         WHILE j <= 2D DO k := 0D;
  252.             WHILE k <= 0D DO
  253.                 p[7][i+d*(j+d*k)] := TRUE; INC(k)
  254.             END;
  255.             INC(j)
  256.         END;
  257.         INC(i)
  258.     END;
  259.     class[7] := 1D;
  260.     piecemax[7] := 0D+d*2D+d*d*0D;
  261.  
  262.     i := 0D;
  263.     WHILE i <= 0D DO j := 0D;
  264.         WHILE j <= 0D DO k := 0D;
  265.             WHILE k <= 2D DO
  266.                 p[8][i+d*(j+d*k)] := TRUE; INC(k)
  267.             END;
  268.             INC(j)
  269.         END;
  270.         INC(i)
  271.     END;
  272.     class[8] := 1D;
  273.  piecemax[8] := 0D+d*0D+d*d*2D;
  274.  
  275.     i := 0D;
  276.     WHILE i <= 1D DO j := 0D;
  277.         WHILE j <= 1D DO k := 0D;
  278.             WHILE k <= 0D DO
  279.                 p[9][i+d*(j+d*k)] := TRUE; INC(k)
  280.             END;
  281.             INC(j)
  282.         END;
  283.         INC(i)
  284.     END;
  285.     class[9] := 2D;
  286.     piecemax[9] := 1D+d*1D+d*d*0D;
  287.  
  288.     i := 0D;
  289.     WHILE i <= 1D DO j := 0D;
  290.         WHILE j <= 0D DO k := 0D;
  291.             WHILE k <= 1D DO
  292.                 p[10][i+d*(j+d*k)] := TRUE; INC(k)
  293.             END;
  294.             INC(j)
  295.         END;
  296.         INC(i)
  297.     END;
  298.     class[10] := 2D;
  299.     piecemax[10] := 1D+d*0D+d*d*1D;
  300.  
  301.     i := 0D;
  302.     WHILE i <= 0D DO j := 0D;
  303.         WHILE j <= 1D DO k := 0D;
  304.             WHILE k <= 1D DO
  305.                 p[11][i+d*(j+d*k)] := TRUE; INC(k)
  306.             END;
  307.             INC(j)
  308.         END;
  309.         INC(i)
  310.     END;
  311.     class[11] := 2D;
  312.     piecemax[11] := 0D+d*1D+d*d*1D;
  313.  
  314.     i := 0D;
  315.     WHILE i <= 1D DO j := 0D;
  316.         WHILE j <= 1D DO k := 0D;
  317.             WHILE k <= 1D DO
  318.                 p[12][i+d*(j+d*k)] := TRUE; INC(k)
  319.             END;
  320.             INC(j)
  321.         END;
  322.         INC(i)
  323.     END;
  324.     class[12] := 3D;
  325.     piecemax[12] := 1D+d*1D+d*d*1D;
  326.  
  327.     piececount[0] := 13D;
  328.     piececount[1] := 3D;
  329.     piececount[2] := 1D;
  330.     piececount[3] := 1D;
  331.     m := 1D+d*(1D+d*1D);
  332.     kount := 0;
  333.     IF Fit(0, m) THEN n := Place(0, m)
  334.     ELSE WriteString("Error1 in Puzzle$")
  335.     END;
  336.     IF ~ Trial(n) THEN WriteString("Error2 in Puzzle.$")
  337.     ELSIF kount # 2005D THEN WriteString("Error3 in Puzzle.$")
  338.     END
  339. END Puzzle;
  340.  
  341.  
  342.    (* Sorts an array using quicksort *)
  343.  
  344.     PROCEDURE Initarr();
  345.         VAR i, temp: LONGINT;
  346.     BEGIN
  347.         Initrand();
  348.         biggest := 0; littlest := 0; i := 1D;
  349.         WHILE i <= LONG(sortelements) DO
  350.             temp := Rand();
  351.             sortlist[i] := temp - (temp DIV 100000D)*100000D - 50000D;
  352.             IF sortlist[i] > biggest THEN biggest := sortlist[i]
  353.             ELSIF sortlist[i] < littlest THEN littlest := sortlist[i]
  354.             END ;
  355.             INC(i)
  356.         END
  357.     END Initarr;
  358.  
  359.     PROCEDURE Quicksort(VAR a: ARRAY OF LONGINT; l,r: LONGINT);
  360.   (* quicksort the array A from start to finish *)
  361.         VAR i,j,x,w: LONGINT;
  362.     BEGIN
  363.         i:=l; j:=r;
  364.         x:=a[(l+r) DIV 2D];
  365.         REPEAT
  366.             WHILE a[i]<x DO i := i+1D END;
  367.             WHILE x<a[j] DO j := j-1D END;
  368.             IF i<=j THEN
  369.                 w := a[i];
  370.                 a[i] := a[j];
  371.                 a[j] := w;
  372.                 i := i+1D;    j := j-1D
  373.             END ;
  374.         UNTIL i > j;
  375.         IF l<j THEN Quicksort(a,l,j) END;
  376.         IF i<r THEN Quicksort(a,i,r) END
  377.     END Quicksort;
  378.  
  379. PROCEDURE Quick ();
  380. BEGIN
  381.     Initarr();
  382.     Quicksort(sortlist,1,sortelements);
  383.     IF (sortlist[1] # littlest) OR (sortlist[sortelements] # biggest) THEN  WriteString( " Error in Quick.$") END ;
  384. END Quick;
  385.  
  386.  
  387.     (* Sorts an array using bubblesort *)
  388.  
  389.     PROCEDURE bInitarr();
  390.         VAR i, temp: LONGINT;
  391.     BEGIN
  392.         Initrand();
  393.         biggest := 0; littlest := 0; i := 1D;
  394.         WHILE i <= LONG(srtelements) DO
  395.             temp := Rand();
  396.             sortlist[i] := temp - (temp DIV 100000D)*100000D - 50000D;
  397.             IF sortlist[i] > biggest THEN biggest := sortlist[i]
  398.             ELSIF sortlist[i] < littlest THEN littlest := sortlist[i]
  399.             END ;
  400.             INC(i)
  401.         END
  402.     END bInitarr;
  403.  
  404. PROCEDURE Bubble();
  405.     VAR i, j: LONGINT;
  406. BEGIN
  407.     bInitarr();
  408.     top:=srtelements;
  409.     WHILE top>1D DO
  410.         i:=1D;
  411.         WHILE i<top DO
  412.             IF sortlist[i] > sortlist[i+1D] THEN
  413.                 j := sortlist[i];
  414.                 sortlist[i] := sortlist[i+1D];
  415.                 sortlist[i+1D] := j;
  416.             END ;
  417.             i:=i+1D;
  418.         END;
  419.         top:=top-1D;
  420.     END;
  421.     IF (sortlist[1] # littlest) OR (sortlist[srtelements] # biggest) THEN WriteString("Error3 in Bubble.$") END ;
  422. END Bubble;
  423.  
  424.     (* Sorts an array using treesort *)
  425.  
  426.     PROCEDURE tInitarr();
  427.         VAR i, temp: LONGINT;
  428.     BEGIN
  429.         Initrand();
  430.         biggest := 0; littlest := 0; i := 1D;
  431.         WHILE i <= LONG(sortelements) DO
  432.             temp := Rand();
  433.             sortlist[i] := temp - (temp DIV 100000D)*100000D - 50000D;
  434.             IF sortlist[i] > biggest THEN biggest := sortlist[i]
  435.             ELSIF sortlist[i] < littlest THEN littlest := sortlist[i]
  436.             END ;
  437.             INC(i)
  438.         END
  439.     END tInitarr;
  440.  
  441.     PROCEDURE CreateNode (VAR t: node; n: LONGINT);
  442.     BEGIN
  443.         ALLOCATE(t, SIZE(nodeDesc));
  444.         t^.left := NIL; t^.right := NIL;
  445.         t^.val := n
  446.     END CreateNode;
  447.  
  448.     PROCEDURE Insert(n: LONGINT; t: node);
  449.     (* insert n into tree *)
  450.     BEGIN
  451.         IF n > t^.val THEN
  452.             IF t^.left = NIL THEN CreateNode(t^.left,n)
  453.             ELSE Insert(n,t^.left)
  454.             END
  455.         ELSIF n < t^.val THEN
  456.             IF t^.right = NIL THEN CreateNode(t^.right,n)
  457.             ELSE Insert(n,t^.right)
  458.             END
  459.         END
  460.     END Insert;
  461.  
  462.     PROCEDURE Checktree(p: node): BOOLEAN;
  463.     (* check by inorder traversal *)
  464.         VAR result: BOOLEAN;
  465.     BEGIN
  466.         result := TRUE;
  467.         IF p^.left # NIL THEN
  468.             IF p^.left^.val <= p^.val THEN result := FALSE;
  469.             ELSE result := Checktree(p^.left) & result
  470.             END
  471.         END ;
  472.         IF  p^.right # NIL THEN
  473.             IF p^.right^.val >= p^.val THEN result := FALSE;
  474.             ELSE result := Checktree(p^.right) & result
  475.             END
  476.         END;
  477.         RETURN result
  478.     END Checktree;
  479.  
  480. PROCEDURE Trees();
  481.     VAR i: LONGINT;
  482. BEGIN
  483.     tInitarr();
  484.     ALLOCATE(tree, TSIZE(nodeDesc));
  485.     tree^.left := NIL; tree^.right:=NIL; tree^.val:=sortlist[1];
  486.     i := 2D;
  487.     WHILE i <= LONG(sortelements) DO
  488.         Insert(sortlist[i],tree);
  489.         INC(i)
  490.     END;
  491.     IF ~ Checktree(tree) THEN WriteString(" Error in Tree.$") END;
  492. END Trees;
  493.  
  494.  
  495. PROCEDURE Time(s: ARRAY OF CHAR; p: Proc; base, fbase: REAL);
  496.     VAR timer: LONGINT;
  497. BEGIN
  498.     timer := Getclock();
  499.     p;
  500.     timer := Getclock()-timer;
  501.     WriteString(s);
  502.     WriteInt(SHORT(timer), 8); WriteLn;
  503.     fixed := fixed + FLOAT(timer)*base;
  504.     floated := floated + FLOAT(timer)*fbase
  505. END Time;
  506.  
  507. PROCEDURE main2(i: INTEGER);
  508. BEGIN
  509.     fixed := 0.0;  floated := 0.0;
  510.     Time("Puzzle ", Puzzle, puzzlebase, puzzlebase);
  511.     Time("Quick  ", Quick, quickbase, quickbase);
  512.     Time("Bubble ", Bubble, bubblebase, bubblebase);
  513.     Time("Tree   ", Trees, treebase, treebase);
  514. END main2;
  515.  
  516. PROCEDURE main;
  517. BEGIN
  518.     fixed := 0.0;  floated := 0.0;
  519.     Time("Puzzle ", Puzzle, puzzlebase, puzzlebase);
  520.     Time("Quick  ", Quick, quickbase, quickbase);
  521.     Time("Bubble ", Bubble, bubblebase, bubblebase);
  522.     Time("Tree   ", Trees, treebase, treebase);
  523.     WriteLn;
  524.     main2(19);
  525. END main;
  526.  
  527. BEGIN
  528.  OpenOutput("H3.Mac");
  529.  WriteString("Hennessy3 mit MacMETH 3.2 : "); WriteLn;
  530.  WriteLn;
  531.     main;
  532.  CloseOutput;
  533.  WriteLn;
  534.  WriteString("any key to terminate. "); WriteLn;
  535.  Read(ch);
  536. END Hennessy3.
  537.